HPAVC/HPAVC CD-ROM.iso/pc/TUT17.ZIP/TUTPRO17.PAS

Pascal/Delphi Source File | 1995-01-17 | 14.6 KB | 472 lines

{$X+}
USES crt,gfx3;

Const jump = 64;       { Number of pixels active at once }
      sjump = 6;       { 1 shl 6 = 64 }

TYPE
        FontDat = Array [' '..'Z',1..16,1..16] of byte; {Our main font }
        target = record
                 herex,herey : integer;
                 targx,targy : integer;
                 dy,dx : integer;
                 active : boolean;
                 col : byte;
                 num:integer;
             END;
        PixelDat = Array [1..4095] of target; { This is the maximum number
                                                of points we canb fit in a
                                                segment... }

VAR Font : ^FontDat;                          { Our nice font }
    nextrow : ^PixelDat;
    scr : array [' '..'Z',1..8,1..8] of byte; { The basic bios font }
    Vir2 : VirtPtr;
    Vaddr2 : Word;                            { Spare virtual screen }
    counter:integer;
    PosLoop:integer;
    dir : boolean;
    pathx,pathy:array [1..314] of integer;    { Path of origination }
    arbpal : array [1..8,1..3] of byte;       { Used to remember certain
                                                colors }



{──────────────────────────────────────────────────────────────────────────}
Procedure Bigmsg (x,y:integer;msg:string);
  { This draws string msg to screen in the bios font, but bigger }
VAR loop1,loop2,loop3,loop4,loop5:integer;
BEGIN
  for loop1:=1 to length (msg) do
    for loop2:=1 to 8 do
      for loop3:=1 to 8 do
        if (scr[msg[loop1],loop3,loop2]<>0) then BEGIN
          for loop4:=1 to 4 do
            for loop5:=1 to 8 do
              putpixel (x+(loop1*32)+(loop2*4)+loop4,y+(loop3*8)+loop5,
                getpixel (x+(loop1*32)+(loop2*4)+loop4,y+(loop3*8)+loop5,vaddr2)+51,vaddr);
        END;
END;




{──────────────────────────────────────────────────────────────────────────}
Procedure Static;
  { This moves the static and tunes in to our background logo }
VAR loop1,loop2,count,count2,count3:integer;
BEGIN
  flip (vaddr2,vaddr);
  Bigmsg (0,60,'ASPHYXIA');
  flip (vaddr,vga);
  count:=0;
  count2:=0;
  for loop2:=1 to 100 do BEGIN
    waitretrace;
    for loop1:=99 to 150 do BEGIN
      count:=random (64);
      pal (loop1,count,count,count);
    END;
    for loop1:=150 to 201 do BEGIN
      count:=random (64);
      pal (loop1,count,count,count);
    END;
  END;   { Do the static for a while }

  repeat
    inc (count);
    if count>10 then BEGIN
      count:=0;
      inc (count2);
    END;
    waitretrace;
    for loop1:=99 to 150 do BEGIN
      count3:=random (64-count2);
      if count3<0 then count3:=0;
      pal (loop1,count3,count3,count3);
    END;
    for loop1:=150 to 201 do BEGIN
      count3:=random (64);
      count3:=count3+count2;
      if count3>63 then count3:=63;
      pal (loop1,count3,count3,count3);
    END;
  until count2>63; { Static fade in Asphyxia logo }

  delay (500);
  for loop1:=30 to 62 do BEGIN
    line (0,loop1*2,319,loop1*2,0,vga);
    delay (5);
  END;
  for loop1:=62 downto 30 do BEGIN
    line (0,loop1*2+1,319,loop1*2+1,0,vga);
    delay (5);
  END;  { Erase logo with lines }
  delay (1000);
  while keypressed do readkey;
END;


{──────────────────────────────────────────────────────────────────────────}
Procedure Fadeup;
  { This fades up the pallette to white }
VAR loop1,loop2:integer;
    Tmp : Array [1..3] of byte;
BEGIN
  For loop1:=1 to 64 do BEGIN
    WaitRetrace;
    For loop2:=0 to 255 do BEGIN
      Getpal (loop2,Tmp[1],Tmp[2],Tmp[3]);
      If Tmp[1]<63 then inc (Tmp[1]);
      If Tmp[2]<63 then inc (Tmp[2]);
      If Tmp[3]<63 then inc (Tmp[3]);
      Pal (loop2,Tmp[1],Tmp[2],Tmp[3]);
    END;
  END;
END;


{──────────────────────────────────────────────────────────────────────────}
Procedure FadeTo (name:string);
  { This procedure fades the screen to name ... if you use this for yourself,
    you will need to cut out the extra stuff I do in here specific to this
    program }
VAR loop1,loop2:integer;
    tmp,pall2:array[0..255,1..3] of byte;
    f:file;
BEGIN
  assign (f,name);
  reset (f,1);
  blockread (f,pall2,768);
  close (f);
  for loop1:=100 to 150 do BEGIN
    pall2[loop1,1]:=loop1-100;
    pall2[loop1,2]:=loop1-100;
    pall2[loop1,3]:=loop1-100;
  END;  { Set the background colors }
  waitretrace;
  for loop1:=0 to 255 do
    getpal (loop1,tmp[loop1,1],tmp[loop1,2],tmp[loop1,3]);

  For loop1:=1 to 64 do BEGIN
    For loop2:=0 to 255 do BEGIN
      If Tmp[loop2,1]<Pall2[loop2,1] then inc (Tmp[loop2,1]);
      If Tmp[loop2,2]<Pall2[loop2,2] then inc (Tmp[loop2,2]);
      If Tmp[loop2,3]<Pall2[loop2,3] then inc (Tmp[loop2,3]);
      If Tmp[loop2,1]>Pall2[loop2,1] then dec (Tmp[loop2,1]);
      If Tmp[loop2,2]>Pall2[loop2,2] then dec (Tmp[loop2,2]);
      If Tmp[loop2,3]>Pall2[loop2,3] then dec (Tmp[loop2,3]);
    END;
    WaitRetrace;
    for loop2:=0 to 255 do
      pal (loop2,tmp[loop2,1],tmp[loop2,2],tmp[loop2,3]);
  END;
END;


{──────────────────────────────────────────────────────────────────────────}
Procedure Show (x,y:integer;ch:string);
  { This dumps string ch to screen at x,y in our main font }
VAR loop1,loop2,loop3:integer;
BEGIN
  for loop3:=1 to length (ch) do
    For loop1:=1 to 16 do
      for loop2:=1 to 16 do
        if Font^[ch[loop3],loop2,loop1]<>0 then
          putpixel (x+loop1+(loop3*17),y+loop2,getpixel (x+loop1+(loop3*17),y+loop2,vaddr2)+51,VGA);
END;


{──────────────────────────────────────────────────────────────────────────}
Procedure Eye_Popper;
  { This fades up the colors used in our main font }
VAR Loop1,loop2:integer;
    tmp : array [1..3] of byte;
BEGIN
  if keypressed then exit;
  for loop1:=1 to 63 do
    for loop2:=1 to 8 do BEGIN
      Waitretrace;
      Getpal (loop2,tmp[1],tmp[2],tmp[3]);
      if tmp[1]<63 then inc (tmp[1]);
      if tmp[2]<63 then inc (tmp[2]);
      if tmp[3]<63 then inc (tmp[3]);
      pal (loop2,tmp[1],tmp[2],tmp[3]);
    END;
  for loop1:=151 to 200 do
    pal (loop1,63,63,63);
END;


{──────────────────────────────────────────────────────────────────────────}
Procedure FadeOutText;
  { This fades out the colors of our main font to the colors of the background
    static }
VAR Loop1,loop2:integer;
    tmp : array [1..3] of byte;
BEGIN
  if keypressed then exit;
  for loop1:=1 to 63 do BEGIN
    Waitretrace;
    for loop2:=151 to 200 do BEGIN
      Getpal (loop2,tmp[1],tmp[2],tmp[3]);
      if tmp[1]>loop2-151 then dec (tmp[1]);
      if tmp[2]>loop2-151 then dec (tmp[2]);
      if tmp[3]>loop2-151 then dec (tmp[3]);
      pal (loop2,tmp[1],tmp[2],tmp[3]);
    END;
  END;
  delay (100);
END;


{──────────────────────────────────────────────────────────────────────────}
Procedure Move_Em_Out (num:integer;del:byte);
  { This procedure runs through each pixel that is active and moves it closer
    to its destination }
VAR loop2:integer;
BEGIN
  if del<>0 then delay (del);
  for loop2:=1 to num do
    if nextrow^[loop2].active then with nextrow^[loop2] do BEGIN
      putpixel (herex shr sjump,herey shr sjump,
                getpixel (herex shr sjump,herey shr sjump,vaddr),vga);
        { Restore old bacground }
      herex:=herex-dx;
      herey:=herey-dy;  { Move pixel one step closer }
      putpixel (herex shr sjump,herey shr sjump,col,vga); { Put down pixel }
      dec (num);
      if num=0 then BEGIN
        active:=false;
        putpixel (herex shr sjump,herey shr sjump,col,vaddr);
      END;  { If destination reached, deactivate }
    END;
END;


{──────────────────────────────────────────────────────────────────────────}
Procedure Doletter (msg : char; dx,dy : integer);
  { This procedure activates the pixels necessary to draw a letter }
VAR loop1,loop2:integer;
    x,y : Integer;
BEGIN
  if keypressed then exit;
  for loop2:=1 to 16 do BEGIN
    for loop1:=1 to 16 do     { Our font is 16x16 }
      if Font^[msg,loop1,loop2]<>0 then BEGIN { Don't do black pixels }
        if dir then PosLoop:=PosLoop+1
          else PosLoop:=PosLoop-1;
        if PosLoop=315 then PosLoop:=1;
        if PosLoop=0 then PosLoop:=314;
        X:=pathx[PosLoop]+160;
        y:=pathy[PosLoop]+100;     { Find point of origination }

        nextrow^ [counter].herex:=x shl sjump;
        nextrow^ [counter].herey:=y shl sjump;
          { This is where I am }
        nextrow^ [counter].targx:=(dx+loop2) shl sjump;
        nextrow^ [counter].targy:=(dy+loop1) shl sjump;
          { This is where I want to be }
        nextrow^ [counter].dx:=(nextrow^[counter].herex-nextrow^[counter].targx) div jump;
        nextrow^ [counter].dy:=(nextrow^[counter].herey-nextrow^[counter].targy) div jump;
          { This is how I get there }
        nextrow^ [counter].col:=Font^[msg,loop1,loop2];
        nextrow^ [counter].active:=TRUE;
        nextrow^ [counter].num:=jump;
        move_em_out(jump,6);

        inc (counter);
        if counter=jump+1 then counter:=1;
      END;
  END;
END;



{──────────────────────────────────────────────────────────────────────────}
Procedure DoPic;
  { This procedure morphs in the tank }
VAR f:file;
    ch:byte;
    count,loop1,loop2:integer;
    ourpal : array [0..255,1..3] of byte;
BEGIN
  cls (vaddr,0);
  getmem (nextrow,sizeof(nextrow^));
  GetMem(Vir2,64000);
  Vaddr2 := Seg(Vir2^);
  for loop2:=1 to 4095 do
    nextrow^[loop2].active:=false;

  assign (f,'tut17.cel');
  reset (f,1);
  seek (f,32);
  blockread (f,ourpal,768);
  for loop1:=0 to 255 do
    pal (loop1,ourpal[loop1,1],ourpal[loop1,2],ourpal[loop1,3]);
  count:=1;
  for loop2:=1 to 60 do
    for loop1:=1 to 160 do BEGIN
      blockread (f,ch,1);     { Go through the pic, and activate non-black
                                pixels }
      if ch<>0 then BEGIN
        nextrow^ [count].herex:=random (320) shl sjump;
        nextrow^ [count].herey:=random (200) shl sjump;
          { This is where I am }
        nextrow^ [count].targx:=(loop1+80) shl sjump;
        nextrow^ [count].targy:=(loop2+70) shl sjump;
          { This is where I want to be }
        nextrow^ [count].dx:=(nextrow^[count].herex-nextrow^[count].targx) div jump;
        nextrow^ [count].dy:=(nextrow^[count].herey-nextrow^[count].targy) div jump;
          { This is how I get there }
        nextrow^ [count].col:=ch;
        nextrow^ [count].active:=TRUE;
        nextrow^ [count].num:=jump;
        inc (count);
      END;
  END;
  close (f);
  for loop1:=0 to 64 do
    move_em_out (count,0);  { Move pixels to targets }
  delay (2000);
  fadeup;
END;

{──────────────────────────────────────────────────────────────────────────}
Procedure Init;
VAR f:file;
    loop1,loop2:integer;
    loopie:real;
BEGIN
  getmem (Font,sizeof(Font^));

  for loop2:=1 to jump do
    nextrow^[loop2].active:=false;

  Assign(f,'gods.Fnt');
  Reset(f,1);
  Blockread(F,Font^,SizeOf(Font^));
  Close(f);

  assign (f,'biostext.dat');
  reset (f,1);
  Blockread (f,scr,sizeof (scr));
  close (f);

  counter:=1;
  PosLoop:=1;
  dir:=true;
  loopie:=0;
  for loop1:=1 to 314 do BEGIN
    loopie:=loopie+0.02;
    pathX[loop1]:=round(150*cos (loopie));
    pathy[loop1]:=round(90*sin (loopie));
  END;    { Generate our path of origination }
  cls (vga,0);
  cls (vaddr,0);
  cls (vaddr2,0);
  for loop1:=0 to 319 do
    for loop2:=0 to 199 do
      putpixel (loop1,loop2,random (50)+100,vaddr2); { Fill the screen with static }
  flip (vaddr2,vaddr);
  flip (vaddr,vga);
  fadeto ('game01.col');
  for loop1:=1 to 8 do
    getpal (loop1,arbpal[loop1,1],arbpal[loop1,2],arbpal[loop1,3]);
END;


{──────────────────────────────────────────────────────────────────────────}
Procedure Play;
VAR loop1,loop2:integer;
    message : Array [1..10] of string;
BEGIN
  DoPic;
  init;
  while keypressed do readkey;
             {[                 ]}
  message[1]:='';
  message[2]:='';
  message[3]:='   PIXEL TEXT   ';
  message[4]:='';
  message[5]:='   A  ROUTINE';
  message[6]:='';
  message[7]:='      BY...';
  message[9]:='';
 message[10]:='';
  for loop2:=1 to 7 do BEGIN
    For loop1:=1 to length (message[loop2]) do BEGIN
      doletter (message[loop2][loop1],loop1*17,loop2*17);
      dir:=not(dir);
    END;
    for loop1:=1 to jump do move_em_out(jump,6);
  END;

  eye_popper;
  For loop1:=1 to 7 do
    show (0,loop1*17,message[loop1]);
  fadeouttext;
  flip (vaddr2,vaddr);
  flip (vaddr,vga);

  for loop1:=1 to 8 do
    pal (loop1,arbpal[loop1,1],arbpal[loop1,2],arbpal[loop1,3]);
  message[1]:='   TUNING...';
  For loop1:=1 to length (message[1]) do BEGIN
    if message[1][loop1]='.' then for loop2:=1 to 20 do
      move_em_out(jump,6);
    doletter (message[1][loop1],loop1*17,100);
    dir:=not(dir);
  END;
  for loop1:=1 to jump do move_em_out(jump,6);

  eye_popper;
  show (0,100,message[1]);
  fadeouttext;

  static;

  freemem (vir2,sizeof (vir2^));
END;


BEGIN
  clrscr;
  writeln ('Hi there ... welcome to the seventeenth Asphyxia VGA Trainer ... and');
  writeln ('the last one on demo effects for a while ... I am going to be doing');
  writeln ('more work on the theory aspect in future trainers.');
  writeln;
  writeln ('This is an effect I first saw in an Extreme demo, and features ''Pixel');
  writeln ('Text'', with various dots forming letters. Also included are some crossfades');
  writeln ('and a static routine.');
  writeln;
  writeln ('Check out the GFX3 unit for a faster putpixel...');
  writeln;
  writeln ('The tank was drawn by Fubar a while ago when he was starting to learn');
  writeln ('3D Studio. The font I found somewhere on my hard drive.');
  writeln;
  writeln;
  writeln ('Hit any key to continue ...');
  readkey;
  setmcga;
  setupvirtual;
  play;
  settext;
  shutdown;
  Writeln ('All done. This concludes the seventeenth sample program in the ASPHYXIA');
  Writeln ('Training series. You may reach DENTHOR under the names of GRANT');
  Writeln ('SMITH/DENTHOR/ASPHYXIA on the ASPHYXIA BBS.I also occasinally read');
  Writeln ('RSAProg, comp.lang.pascal and comp.sys.ibm.pc.demos. E-mail me at :');
  Writeln ('    [e-mail]');
  Writeln ('The numbers are available in the main text. You may also write to me at:');
  Writeln ('             Grant Smith');
  Writeln ('             P.O. Box 270');
  Writeln ('             Kloof');
  Writeln ('             3640');
  Writeln ('             Natal');
  Writeln ('             South Africa');
  Writeln ('I hope to hear from you soon!');
  Writeln; Writeln;
  Write   ('Hit any key to exit ...');
  readkey;
END.